;;; A file containing wrapper functions for different lisps

(in-package :gwee)

(defun init-base-pathnames ()
  (setf *gwee-base-pathname*
	#+lispworks
	;; We do it this way because translating the pathname for some
	;; reason keeps the filename.
	(let ((base (translate-pathname (lw:lisp-image-name)
					"/**/MacOS/*"
					"/**/Resources/")))
	  (make-pathname :directory (pathname-directory base)
			 :host (pathname-host base)
			 :device (pathname-device base)))
	#+sbcl (let* ((tmp (sb-posix:getcwd))
                      (cwd (sb-ext:parse-native-namestring (if (char= (elt tmp (1- (length tmp))) #\/)
                                                               tmp
                                                               (format nil "~a/" tmp))))
                      (executable (sb-ext:parse-native-namestring (first sb-ext:*posix-argv*)))
                      (image-path (if (eq (first (pathname-directory executable))
                                          :absolute)
                                      executable
                                      (make-pathname :directory (append
                                                                 (pathname-directory cwd)
                                                                 (cdr (pathname-directory executable)))
                                                     :defaults cwd))))
                 (make-pathname :name nil :type nil :defaults image-path
                                :directory (append (butlast (pathname-directory image-path) 1)
                                                   (list "Resources"))))
        #+ccl (let* ((cwd (ccl:mac-default-directory))
                     (executable (ccl:native-to-pathname (first ccl:*command-line-argument-list*)))
                     (image-path (if (eq (first (pathname-directory executable))
                                         :absolute)
                                     executable
                                     (make-pathname :directory (append
                                                                (pathname-directory cwd)
                                                                (cdr (pathname-directory executable)))
                                                    :defaults cwd))))
                #+darwin
                (make-pathname :name nil :type nil :defaults image-path
                               :directory (append (butlast (pathname-directory image-path) 1)
                                                  (list "Resources")))
                #+windows
                (make-pathname :name nil :type nil :defaults image-path
                               :directory (append (pathname-directory image-path)
                                                  (list "Resources"))))
	#+allegro (gwee:native-namestring
                   (make-pathname :name nil
                                  :type nil
                                  :defaults (or #.*compile-file-pathname* *load-pathname*)))
	#-(or sbcl lispworks allegro ccl)
	(error "you're using an unsupported lisp!")
	;; *resource-base-pathname* *gwee-base-pathname*
        ))

(defun error-pathname (dir &optional (file-fmt "") &rest args)
  #+lispworks (translate-pathname (make-pathname :defaults (lw:lisp-image-name) :name nil :type nil)
                                  "/**/*/Contents/MacOS/*"
                                  (format nil "/**/~a/~a" dir (apply 'format nil file-fmt args)))
  #+ccl (format nil "~a~a/~a" (top-level-dir) dir (apply 'format nil file-fmt args))
  #+sbcl (format nil "~a~a/~a" (top-level-dir) dir (apply 'format nil file-fmt args))
  #+allegro (format nil "~a~a\\~a" (excl.osi:current-directory) dir (apply 'format nil file-fmt args))
  #-(or lispworks sbcl allegro ccl) (error "error-pathname: unimplemented"))

(defun exit ()
  ;; #+sbcl (sb-ext:quit)
  ;; #+lispworks (lw:quit)
  ;; #+allegro (excl:exit)
  ;; #+ccl (ccl::quit)
  ;; #-(or sbcl lispworks allegro ccl) (error "exit: unimplemented")
  )

(defun print-backtrace (s)
  #+lispworks (mp:map-process-backtrace mp:*current-process* (lambda (x) (print x s)))
  #+sbcl (sb-debug:backtrace 1000 s)
  #+allegro (top-level.debug:zoom s)
  #+ccl (ccl::print-call-history :stream s)
  #-(or lispworks sbcl allegro ccl) (error "print-backtrace: unimplemented"))

;;; locks

(defun make-lock ()
  #+lispworks (mp:make-lock)
  #+allegro (mp:make-process-lock)
  #+ccl (ccl:make-lock)
  #+sbcl (sb-thread:make-mutex)
  #-(or allegro lispworks ccl sbcl) (error "make-lock: unimplemented"))

(defun process-lock (lock)
  #+lispworks (mp:process-lock lock)
  #+allegro (mp:process-lock lock)
  #+ccl (ccl:grab-lock lock)
  #+sbcl (sb-thread:grab-mutex lock)
  #-(or allegro lispworks ccl sbcl) (error "process-lock: unimplemented"))

(defun process-unlock (lock)
  #+lispworks (mp:process-unlock lock)
  #+allegro (mp:process-unlock lock)
  #+ccl (ccl:release-lock lock)
  #+sbcl (sb-thread:release-mutex lock)
  #-(or lispworks allegro ccl sbcl) (error "process-unlock: unimplemented"))

(defmacro with-lock ((lock) &body body)
  `(progn
     (process-lock ,lock)
     (unwind-protect
          (progn ,@body)
       (process-unlock ,lock))))

(defun current-process ()
  #+lispworks (mp:get-current-process)
  #+allegro mp:*current-process*
  #+ccl ccl:*current-process*
  #+sbcl sb-thread:*current-thread*
  #-(or allegro lispworks ccl sbcl) (error "current-process: unimplemented"))

(defun process-stop (process)
  #+allegro (mp:process-disable process)
  #+lispworks (mp:process-stop process)
  #+ccl (ccl:process-suspend process)
  #-(or allegro lispworks ccl) (error "process-stop: unimplemented"))

(defun process-start (process)
  #+allegro (mp:process-enable process)
  #+lispworks (mp:process-unstop process)
  #+ccl (ccl:process-resume process)
  #-(or allegro lispworks ccl) (error "process-start: unimplemented"))

(defun process-run-function (name function)
  #+lispworks (mp:process-run-function name nil function)
  #+ccl (ccl:process-run-function name function)
  #+sbcl (sb-thread:make-thread function :name name) 
  #+allegro (mp:process-run-function name function)
  #-(or ccl lispworks sbcl allegro) (error "process-run-function: unimplemented"))

(defun process-kill (process)
  #+ccl (ccl:process-reset process :kill)
  #-(or ccl) (error "process-kill: unimplemented."))

;;; use the system file save/loader dialog

#+allegro
(require :cg)

#+allegro
(defun choose-file (&key (directory (namestring (gwee:top-level-dir))) file-types)
  (cg:ask-user-for-existing-pathname "Select a log file"
                                     :allowed-types (mapcar (lambda (x)
                                                              (cons (format nil "~a Files" x)
                                                                    (format nil "*.~a" x)))
                                                            file-types)
                                     :initial-directory directory))

#+allegro
(defun choose-new-file (&key (directory (namestring (gwee:top-level-dir))) file-types)
  (cg:ask-user-for-new-pathname "Save log file as a movie"
                                :allowed-types (mapcar (lambda (x)
                                                         (cons (format nil "~a Files" x)
                                                               (format nil "*.~a" x)))
                                                       file-types)
                                :initial-directory directory))

#+lispworks
(defun choose-file ()
  (let ((dialog (objc:invoke "NSOpenPanel" "openPanel")))
    (objc:invoke dialog "setCanChooseFiles:" t)
    (objc:invoke dialog "setTitle:" "Select a log file")
    (objc:invoke dialog "setPrompt:" "Select")
    (when (plusp (objc:invoke dialog "runModalForDirectory:file:types:" (namestring (gwee:top-level-dir)) nil #("txt")))
      (elt (objc:invoke-into '(array string) dialog "filenames") 0))))

#+lispworks
(defun choose-new-file ()
  (let ((dialog (objc:invoke "NSSavePanel" "savePanel")))
    (objc:invoke dialog "setCanCreateDirectories:" t)
    (objc:invoke dialog "setTitle:" "Save log file as a movie")
    (objc:invoke dialog "setExtensionHidden:" t)
    (objc:invoke dialog "setAllowedFileTypes:" #("mpg"))
    (when (plusp (objc:invoke dialog "runModalForDirectory:file:" (namestring (gwee:top-level-dir)) nil))
      (objc:invoke-into 'string dialog "filename"))))

#+ccl
(defun choose-file (&key (directory (gwee:top-level-dir)) file-types)
  (gwee-ccl-dialogs::choose-file-dialog (native-namestring directory) file-types nil nil))

#+ccl
(defun choose-new-file (&key (directory (gwee:top-level-dir)) file-types file)
  (gwee-ccl-dialogs::choose-new-file-dialog (native-namestring directory) file-types file))

#+sbcl
(defun choose-file ()
  (error "can't do choose-file yet."))

#+sbcl
(defun choose-new-file ()
  (error "can't do choose-file yet."))

#+lispworks
(defun run-program (program args &key wait input output (error :output))
  (multiple-value-bind (pipe err)
      (system:run-shell-command (format nil "~a~{ \"~a\"~}" program args)
                                :wait wait
                                :input input
                                :output output
                                :error-output error)
    (values pipe pipe err)))

#+ccl
(defun run-program (program args &key wait input output (error :output) (sharing :private))
  (let ((ext (ccl:run-program program args
                              :wait wait
                              :input input
                              :output output
                              :error error
                              :sharing sharing)))
    (values (ccl:external-process-output-stream ext)
            (ccl:external-process-input-stream ext)
            (ccl:external-process-error-stream ext))))

#-(or lispworks ccl)
(defun run-program (prorgam args &key wait input output (error :output))
  (error "run-program: unimplemented"))

#+lispworks
(defun native-namestring (pathname)
  (namestring pathname))

#+ccl
(defun native-namestring (pathname)
(ccl:native-translated-namestring pathname))

#+allegro
(defun native-namestring (pathname)
  (namestring pathname))

#-(or allegro lispworks ccl)
(defun native-namestring (pathname)
  (error "native-namestring: unimplemented"))